Collection of Tools & Utilities/Collection of Tools and Utilities.iso/graphic/xv_pc16a.zip/XBITMAP.PAS

Pascal/Delphi Source File | 1994-04-22 | 9KB | 312 lines

PROGRAM XBitmap;
{
 XView-PC for Turbo Pascal demonstration.
 by Antonio Carlos Moreirao de Queiroz - [e-mail]
 The program reads and plots Windows 16 colors bitmaps.
 Demonstration of use of instances of a window.
 V. 1.0 - 22/05/93
 V. 2.0 - 30/10/93
 V. 2.1 - 22/04/94
}

USES Graph,XView;

TYPE
  ptr_visor=^visor;
  visor=RECORD {instance of window}
    fwindow,tname,cbitmap,bnew:Xv_opaque;
    pal:ARRAY[0..15] OF RECORD
      r,g,b:INTEGER
    END;
    biHeight,biWidth:INTEGER
  END;

VAR
  menuglobal:Xv_opaque;       {menu in all windows}
  memory,terminal:Xv_opaque;  {information window}
  visor1:ptr_visor;           {instance data pointer}
  archive: FILE;              {for reading bitmaps}
  board,mode,iii:INTEGER;     {graphics mode selection}

FUNCTION CreateInstance:ptr_visor; FORWARD;
{$F+}
{Here because used in AdjustSize}
PROCEDURE Destroy(w:Xv_opaque); FORWARD;
PROCEDURE ReDraw(obj:Xv_opaque); FORWARD;
{$F-}

FUNCTION Si(i:LONGINT):STRING;
VAR
  txt:STRING;
BEGIN
  Str(i,txt);
  Si:=txt
END;

FUNCTION Smaller(a,b:WORD):WORD;
BEGIN
  IF a>b THEN Smaller:=b ELSE Smaller:=a
END;

FUNCTION AdjustSize(obj:Xv_opaque):BOOLEAN;
{Adjusts the size of the window to the bitmap}
BEGIN
  WITH ptr_visor(obj^.client_data)^ DO BEGIN
    {Turns off the notify_handlers temporarily}
    fwindow^.notify_handler:=Nothing;
    cbitmap^.notify_handler:=Nothing;
    {Closes the window, but impedes the end of the program}
    close_window(fwindow);
    xv_end:=FALSE;
    {Adjusts the size and reopens without redrawing the canvas}
    fwindow^.dx:=BiWidth+2*mrgx+1;
    fwindow^.dy:=BiHeight+mrgx+mrgy+cbitmap^.y+1;
    open_window(fwindow);
    {If impossible...}
    IF not xv_ok THEN BEGIN
      ttysw_output(terminal,'The bitmap is too big'^M^J);
      {Trying a smaller size}
      fwindow^.dy:=200;
      fwindow^.dx:=200;
      open_window(fwindow);
      AdjustSize:=xv_ok
    END
    ELSE AdjustSize:=TRUE;
    {Restores the notify_handlers}
    fwindow^.notify_handler:=Destroy;
    cbitmap^.notify_handler:=ReDraw;
  END
END;

{$F+}

PROCEDURE Destroy(w:Xv_opaque);
{Instance destructor}
BEGIN
  WITH w^ DO BEGIN
    WITH ptr_visor(client_data)^ DO BEGIN
      {Deallocates the window objects}
      Dispose(fwindow);
      Dispose(tname);
      Dispose(cbitmap);
      Dispose(bnew);
    END;
    Dispose(ptr_visor(client_data)) {Frees the instance data}
  END
END;

PROCEDURE ReDraw(obj:Xv_opaque);
{"notify_handler" for the window objects}
VAR
  i,j,k,p,b,kk,ox,oy:WORD;
  buf:ARRAY[0..165] of WORD;
  t,m:BYTE;
LABEL
  Fim;

BEGIN
  WITH ptr_visor(obj^.client_data)^ DO BEGIN {With the present instance...}
    IF tname^.panel_value='' THEN Exit;
    Assign(archive,tname^.panel_value);
    {$I-} Reset(archive,2); {$I+}
    IF IOResult<>0 THEN BEGIN
      ttysw_output(terminal,'File '+tname^.panel_value+' not found'^M^J);
      Exit
    END;
    {Reads the bitmap header}
    BlockRead(archive,buf,59);
    IF buf[0]<>$4D42 THEN BEGIN {Starts with 'BM'}
      ttysw_output(terminal,'The file is not a Windows bitmap'^M^J);
      GoTo Fim;
    END;
    biWidth:=buf[9];   {Width}
    biHeight:=buf[11]; {Height}
    IF buf[14]<>4 THEN BEGIN
      ttysw_output(terminal,'Only 16 colors accepted'^M^J);
      GoTo fim
    END;
    {Saves and updates the palette}
    FOR i:=0 TO 15 DO BEGIN
      k:=27+2*i;
      WITH pal[i] DO BEGIN
        r:=Lo(buf[k+1]);
        g:=Hi(buf[k]);
        b:=Lo(buf[k])
      END
    END;
    FOR i:=0 TO 15 DO BEGIN
      WITH pal[i] DO SetRGBPalette(i,r shr 2,g shr 2,b shr 2);
      SetPalette(i,i)
    END;
    {Adjustes the size and plots the bitmap, or at least its lower left corner}
    IF (obj=cbitmap) or AdjustSize(obj) THEN BEGIN
      k:=BiWidth;
      WHILE k mod 8<>0 DO Inc(k);
      k:=k div 4;
      p:=Smaller(cbitmap^.dx-2,biWidth-1);
      {Plots directly in EGA/VGA 16 colors}
      {$IFNDEF DPMI} {Does not work in protected mode}
      IF GetMaxColor=15 THEN BEGIN
        WITH active_w^.gr_out DO BEGIN {viewport}
          ox:=x1;
          oy:=y1;
        END;
        PortW[$3CE]:=$0205; {VGA mode 2}
        FOR j:=Smaller(cbitmap^.dy-2,biHeight-1) DOWNTO 0 DO BEGIN
          BlockRead(archive,buf,k);
          b:=12;
          kk:=(oy+j)*80+ox shr 3; {First byte in the line}
          m:=$80 shr (ox and 7);  {Initial mask}
          FOR i:=0 TO p DO BEGIN
            Port[$3CE]:=$8; {Sets mask}
            Port[$3CF]:=m;
            t:=Mem[$A000:kk]; {Reads byte...}
            Mem[$A000:kk]:=(Swap(buf[i shr 2]) shr b) and $F; {Writes}
            IF b>0 THEN Dec(b,4) ELSE b:=12;
            IF m=1 THEN BEGIN
              m:=$80;
              Inc(kk)
            END
            ELSE m:=m shr 1
          END
        END;
        PortW[$3CE]:=$0005; {Restores mode 0}
        PortW[$3CE]:=$FF08  {Restores mask}
      END
      ELSE
      {$ENDIF}
      BEGIN {Plots with PutPixel - s-l-o-w -}
        FOR j:=Smaller(cbitmap^.dy-2,biHeight-1) DOWNTO 0 DO BEGIN
          BlockRead(archive,buf,k);
          b:=12;
          FOR i:=0 TO p DO BEGIN
            PutPixel(i,j,(Swap(buf[i shr 2]) shr b) and $F);
            IF b>0 THEN Dec(b,4) ELSE b:=12;
          END
        END
      END
    END
  END;
  fim:
    Close(archive);
    ttysw_output(terminal,'MemAvail='+Si(MemAvail)+' MaxAvail='+Si(MaxAvail)+^M^J);
END;

PROCEDURE ProcessEvents(obj:Xv_opaque);
{"event_handler" for the canvas}
VAR
  i:INTEGER;
BEGIN {Adjusts the palette if the mouse left button is pressed}
  IF ie_code=MS_LEFT THEN
    WITH ptr_visor(obj^.client_data)^ DO
      IF tname^.panel_value<>'' THEN
        FOR i:=0 TO 15 DO BEGIN
          WITH pal[i] DO SetRGBPalette(i,r shr 2,g shr 2,b shr 2);
          SetPalette(i,i)
        END;
END;

PROCEDURE OpenNew(obj:Xv_opaque);
{"notify_handler" for the button}
BEGIN {Creates another panel, if possible}
  visor1:=CreateInstance;
  IF not xv_ok THEN BEGIN
    ttysw_output(terminal,'Impossible to create a new window'^M^J);
    Exit
  END;
  open_window(visor1^.fwindow);
  IF not xv_ok THEN BEGIN
    ttysw_output(terminal,'Impossible to open a new window'^M^J);
    Destroy(visor1^.fwindow);
  END
END;

PROCEDURE TratarMenuGlobal(obj:Xv_opaque);
{"notify_handler" do then menu}
VAR
  txt:STRING;
  i,j,k:INTEGER;
BEGIN
  CASE obj^.sel_menu OF
    1:close_window(active_w);
    2:Back;
    3:xv_end:=TRUE;
    4:ttysw_output(terminal,'MemAvail='+Si(MemAvail)+' MaxAvail='+Si(MaxAvail)+^M^J);
  END
END;

{$F-}

FUNCTION CreateInstance:ptr_visor;
{Creates a new instance}
VAR v:ptr_visor;
BEGIN
  {Tests available memory}
  IF MaxAvail<SizeOf(visor)+5*SizeOf(xv_widget) THEN BEGIN
    xv_ok:=FALSE;
    CreateInstance:=nil;
    Exit
  END;
  New(v);
  WITH v^ DO BEGIN
    normal_client_data:=v;
    fwindow:=xv_create(frame); {Creates the frame}
    WITH fwindow^ DO BEGIN
      xv_label:='Bitmap';
      dx:=226;
      dy:=256;
      menu_name:=menuglobal;
      notify_handler:=Destroy
    END;
    cbitmap:=xv_create(canvas); {Creates the canvas}
    WITH cbitmap^ DO BEGIN
      y:=30;
      notify_handler:=ReDraw;
      event_handler:=ProcessEvents
    END;
    tname:=xv_create(textfield); {Creates the field for the file name}
    WITH tname^ DO BEGIN
      xv_label:='File';
      value_length:=19;
      notify_handler:=ReDraw;
    END;
    bnew:=xv_create(button); {Creates the button that creates another window}
    WITH bnew^ DO BEGIN
      xv_label:='New';
      y:=15;
      notify_handler:=OpenNew;
    END
  END;
  CreateInstance:=v;
END;

BEGIN
  board:=0;
  IF ParamCount=2 THEN BEGIN
    Val(ParamStr(1),board,iii);
    Val(ParamStr(2),mode,iii)
  END;
  type_hatch:=InterleaveFill;
  xv_init(board,mode);
  menuglobal:=xv_create(menu); {Creates the menu}
  WITH menuglobal^ DO BEGIN
    item_create('Close');
    item_create('Back');
    item_create('Quit');
    item_create('Memory');
    xv_label:='Window';
    notify_handle